home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / dbase / lib19.zip / ARRAY.PRG next >
Text File  |  1992-07-07  |  31KB  |  834 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program...: ARRAY.PRG
  3. *-- Programmer: Ken Mayer (KENMAYER)
  4. *-- Date......: 07/07/1992
  5. *-- Notes.....: These routines deal with filling arrays, sorting arrays, 
  6. *--             and so on ... See README.TXT for details on using this file.
  7. *-------------------------------------------------------------------------------
  8.  
  9. FUNCTION Afill
  10. *-------------------------------------------------------------------------------
  11. *-- Programmer..: Jay Parsons (JPARSONS)
  12. *-- Date........: 04/22/1992
  13. *-- Notes.......: Creates if needed, and fills a row or column of, an array,
  14. *--               with sequential numeric elements starting with nFirst,
  15. *--               increasing by nStep.
  16. *--               Useful for testing routines that require an array ...
  17. *-- Written for.: dBASE IV, 1.1
  18. *-- Rev. History: Original function 03/01/1992.
  19. *--               04/22/92 - Jay Parsons - calling syntax changed
  20. *-- Calls.......: AMASK()              Functon in ARRAY.PRG
  21. *-- Called by...: Any
  22. *-- Usage.......: AFill("<cArrayskel>",<nCount>,<nFirstVal>,<nStep>)
  23. *-- Example.....: lX = AFill("aTest",20,1,10)
  24. *-- Returns.....: .T. (and an array filled with values as in "notes" above)
  25. *-- Parameters..: cArrayskel  = Name of array and optional row/column info
  26. *--               nCount      = number of elements to fill
  27. *--               nFirstVal   = starting value in array
  28. *--               nStep       = number to increment by
  29. *-- Side effects: Creates as public, if needed, and fills array.  Will destroy
  30. *--               existing array of the same name if its dimensions are
  31. *--               inadequate for the data to be filled in.
  32. *-------------------------------------------------------------------------------
  33.  
  34.    parameters cArrayskel, nCount, nFirstval, nStep
  35.    private nAt, cArray, cMask, cElem, nRows, nCols, nFill
  36.    cArray = cArrayskel
  37.    if "[" $ cArray
  38.       cArray = left( cArray, at( "[", cArray ) - 1 )
  39.    endif
  40.    cArray = trim( ltrim( cArray ) )
  41.    cMask = Amask( cArrayskel, "nAt" )
  42.    if at( ",", cMask ) > 0 .and. val( substr( cMask, at( ",", cMask ) + 1 ) ) = 0
  43.       nRows = val( substr( cMask, at( "[", cMask ) + 1 ) )
  44.       nCols = nCount
  45.    else
  46.       nRows = nCount
  47.       nCols = val( substr( cMask, at( ",", cMask ) + 1 ) )
  48.    endif
  49.    nAt = nCount
  50.    cElem = cArray + cMask
  51.    if type( cElem ) = "U"
  52.       release &cArray
  53.       public &cArray
  54.       if nCols > 0
  55.          declare &cArray[ nRows, nCols ]
  56.       else
  57.          declare &cArray[ nRows ]
  58.       endif
  59.    endif
  60.    nFill = nFirstval
  61.    nAt = 0
  62.    do while nAt < nCount
  63.       nAt = nAt + 1
  64.       cElem = cArray + cMask
  65.       store nFill to &cElem
  66.       nFill = nFill + nStep
  67.    enddo
  68.     
  69. RETURN .T.
  70. *-- EoF: Afill()
  71.  
  72. FUNCTION Amask
  73. *-------------------------------------------------------------------------------
  74. *-- Programmer..: Jay Parsons (Jparsons)
  75. *-- Date........: 04/21/1992
  76. *-- Notes.......: Returns a "mask" specifying the desired row or column of
  77. *--               an array.
  78. *-- Written for.: dBASE IV
  79. *-- Rev. History: None
  80. *-- Calls       : None
  81. *-- Called by...: Any
  82. *-- Usage.......: Amask( <cArrayskel>, <cVar> )
  83. *-- Example.....: ? Amask( "Myarray [ , 1 ]", "nAt" )
  84. *-- Returns     : a character value including a passed character string,
  85. *--               which may be used by the calling function to locate array
  86. *--               elements
  87. *-- Parameters..: cArrayskel, a character string including the name of the
  88. *--               array and, if the row or column to be used is not the
  89. *--               first row (or only row if array is one-dimensional),
  90. *--               a bracketed expression with a number indicating the row,
  91. *-                or column if the number is preceded by a comma, to be used.
  92. *--               cVar, name of the memvar to be used by calling function.
  93. *-------------------------------------------------------------------------------
  94.  
  95.    parameters cArrayskel, cVar
  96.    private nAt, cWhich, cMask, cV
  97.    nAt = at( "[", cArrayskel )
  98.    cWhich = "0 ]"
  99.    cV = trim( ltrim( cVar ) )
  100.    if nAt > 0
  101.       cWhich = substr( cArrayskel, nAt + 1 )
  102.    else
  103.       cWhich = "1 ]"
  104.    endif
  105.    if .not. "," $ cArrayskel
  106.       cMask = "[ " + cV + " ]"
  107.    else
  108.       if val( cWhich ) > 0
  109.          cMask = "["+ ltrim( str( val( cWhich ) ) ) + "," + cV + "]"
  110.       else
  111.          cWhich = substr( cWhich, at( ",", cWhich ) + 1 )
  112.          cMask = "[" + cV+ ","+ ltrim( str( val( cWhich ) ) ) + "]"
  113.       endif
  114.    endif
  115.  
  116. RETURN cMask
  117. *-- EoF: Amask()
  118.  
  119. FUNCTION Amean
  120. *-------------------------------------------------------------------------------
  121. *-- Programmer..: Jay Parsons (Jparsons)
  122. *-- Date........: 04/13/1992
  123. *-- Notes.......: Mean of non-blank numeric or date values in specified row
  124. *--             : or column of a specified array.  If the first value is a
  125. *--             : date, averages only dates.  If first value is numeric or
  126. *--             : float, averages only numerics and floats.  Exits returning
  127. *--             : .F. if first value is character or logical, if specified
  128. *--             : row or column does not exist or if there are no
  129. *--             : averageable values.
  130. *--             :
  131. *-- Written for.: dBASE IV Version 1.5.
  132. *-- Rev. History: Original function written 1990
  133. *--             : Adapted to Version 1.5 4/13/1992
  134. *-- Calls       : AMASK()              Function in ARRAY.PRG
  135. *-- Called by...: Any
  136. *-- Usage.......: Amean( <cArrayskel> )
  137. *-- Example.....: ? Amean( "Myarray [ , 1 ]" )
  138. *-- Returns     : a numeric, float or date value, the mean or average, or .F.
  139. *--             : If any of the averaged items are floats, the result will be.
  140. *-- Parameters..: cArrayskel, a character string including the name of the
  141. *--             : array and, if the row or column to be averaged is not the
  142. *--             : first row, a bracketed expression with a number indicating
  143. *--             : the row, or column if the number is preceded by a comma,
  144. *--             : to be averaged.
  145. *-------------------------------------------------------------------------------
  146.  
  147.    parameters cArrayskel
  148.    private nAt,cArray,cMask,cElem,nTot,nCount,xNext,cOktype
  149.    cArray = cArrayskel
  150.    if "[" $ cArray
  151.       cArray = left( cArray, at( "[", cArray ) - 1 )
  152.    endif
  153.    cArray = trim( ltrim( cArray ) )
  154.    cMask = Amask( cArrayskel, "nAt" )
  155.    store 0 to nTot, nCount, nAt
  156.    do while .t.
  157.       nAt = nAt + 1
  158.       cElem = cArray + cMask
  159.       xNext = type( cElem )
  160.       do case
  161.          case xNext = "U"
  162.             exit
  163.          case nAt = 1
  164.             if xNext $ "CL"
  165.                exit
  166.             else
  167.                cOktype = iif( xNext = "D", "D", "NF" )
  168.             endif
  169.          case .not. xNext $ cOktype
  170.             loop
  171.       endcase
  172.       xNext = &cElem
  173.       if isblank( xNext )
  174.          loop
  175.       endif
  176.       if cOktype = "D"
  177.          xNext = xNext - {01/01/01}
  178.       endif
  179.       nTot = nTot + xNext
  180.       nCount = nCount + 1
  181.    enddo
  182.  
  183. RETURN iif( nCount = 0, .F., nTot / nCount ;
  184.      + iif( cOktype = "D", {01/01/01}, 0 ) )
  185. *-- EoF: Amean()
  186.  
  187. FUNCTION Amax
  188. *-------------------------------------------------------------------------------
  189. *-- Programmer..: Jay Parsons (Jparsons)
  190. *-- Date........: 04/13/1992
  191. *-- Notes.......: Finds maximum non-blank numeric, date or character value in
  192. *--             : specified row or column of a specified array.  If the first
  193. *--             : value is character or date, considers only that type.
  194. *--             : If first value is numeric or float, considers only numerics
  195. *--             : and floats.  Exits returning .F. if first value is logical,
  196. *--             : if specified row or column does not exist or if there are no
  197. *               : numeric, date or character values in the row or column.
  198. *--             :
  199. *-- Written for.: dBASE IV Version 1.5.
  200. *-- Rev. History: Original function written 1990
  201. *--             : Adapted to Version 1.5 4/13/1992
  202. *-- Calls       : AMASK()              Function in ARRAY